home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / transq.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  14.5 KB  |  484 lines
  1. ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;     The data in this file contains enhancments.                    ;;;;;
  4. ;;;                                                                    ;;;;;
  5. ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
  6. ;;;     All rights reserved                                            ;;;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  9. ;;;          Compilation environment for TRANSLATED MACSYMA code.        ;;;
  10. ;;;       (c) Copyright 1980 Massachusetts Institute of Technology       ;;;
  11. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  12.  
  13. (in-package "MAXIMA")
  14. ;;; this are COMPILE-TIME macros for TRANSLATE MACSYMA code.
  15. ;;; these guys are either SUBR's LSUBR's or FEXPRS in the interpreter.
  16. ;;; (ask me about why I used FEXPRS sometime ok.) -gjc.
  17.  
  18. (macsyma-module transq macro)
  19. (load-macsyma-macros transm defopt)
  20.  
  21. ;;; Already defined in transl module.
  22. #-cl
  23. (DEFVAR $TR_SEMICOMPILE NIL) ; T if expanding for expr code.
  24.  
  25. ;;; function for putting good info in the UNFASL file.
  26.  
  27.  
  28. ;#+PDP10
  29. ;(PROGN 'COMPILE
  30.  
  31. ;(DECLARE (SPECIAL CMSGFILES))
  32.  
  33. ;(DEFVAR MACRO-FILES NIL)
  34.  
  35. ;(DEFUN UNFASL-ANNOTATE-VERSIONS ()
  36. ;  (LET ((UNFASL (IF (EQ (CAAR (NAMELIST (CAR CMSGFILES))) 'DSK)
  37. ;            (CAR CMSGFILES)
  38. ;            (CADR CMSGFILES))))
  39. ;       (FORMAT UNFASL '|~%;; Compilation by ~A~%|
  40. ;           (STATUS UNAME))
  41. ;       (FORMAT UNFASL '|;; ~15A~A~%|
  42. ;           '|Prelude file:|
  43. ;           (LET ((X (TRUENAME INFILE)))
  44. ;            (NAMESTRING (CONS (CDAR X) (CDR X)))))
  45. ;       (FORMAT UNFASL '|;; ~15A| '|Macro files:|)
  46. ;       (FORMAT UNFASL '|~{~<~%;; ~15X~:;~A ~A~>~^, ~}~%|
  47. ;           (DO ((L NIL (CONS (GET (CAR X) 'VERSION) (CONS (CAR X) L)))
  48. ;            (X MACRO-FILES (CDR X)))
  49. ;           ((NULL X) (NREVERSE L))))))
  50. ;;; END of #+PDP10
  51. ;)
  52.  
  53. (defmacro def-mtrvar (v a &optional (priority 1))
  54.   priority
  55.   ;; ignored variable around for TRANSLATED files pre 
  56.   ;; 3:03pm  Thursday, 11 March 1982 -gjc
  57.   `(progn #-cl 'compile
  58.       (declare-top (special ,v))
  59.  
  60.       (if (or (not (boundp ',v))
  61.           ;; a SYMBOL SET to ITSELF is considered to be
  62.           ;; UNBOUND for our purposes in Macsyma.
  63.           (eq ,v ',v))
  64.           (setq ,v ,a))))
  65.  
  66. (DEFOPT TRD-MSYMEVAL (VAR &rest ignore)
  67.   VAR)
  68.  
  69. (DEFVAR *MAX-EXPT$-EXPAND* 7)
  70.  
  71. (DEFOPT EXPT$ (BAS EXP)
  72.   (if (not (integerp exp))
  73.       (MAXIMA-ERROR `(|Internal TRANSL error. Call GJC| ,BAS ,EXP)))
  74.   (LET* ((ABS-EXP (ABS EXP))
  75.      (FULL-EXP (COND ((NOT (> EXP *MAX-EXPT$-EXPAND*))
  76.               `(INTERNAL-EXPT$ ,BAS ,ABS-EXP))
  77.              (T
  78.               `(^$ ,BAS ,ABS-EXP)))))
  79.     (COND ((MINUSP EXP)
  80.        `(//$ ,FULL-EXP))
  81.       (T FULL-EXP))))
  82.  
  83. (DEFOPT INTERNAL-EXPT$ (EXP-BASE POS-EXP)
  84.   (COND ((= POS-EXP 0)
  85.      ;; BROM  wrote X^0 for symmetry in his code, and this
  86.      ;; macro did some infinite looping! oops.
  87.      ;; X^0 can only happen in hand-written code, in macros
  88.      ;; the general-representation simplifier will get rid
  89.      ;; of it.
  90.      1.0)
  91.     ((= POS-EXP 1)
  92.      EXP-BASE)
  93.     ((NOT (ATOM EXP-BASE))
  94.      (LET ((SYM (GENSYM)))
  95.        `(LET ((,SYM ,EXP-BASE))
  96.           (DECLARE (FLONUM ,SYM))
  97.           (INTERNAL-EXPT$ ,SYM ,POS-EXP))))
  98.     ((= POS-EXP 2)
  99.      `(*$ ,EXP-BASE ,EXP-BASE))
  100.     ((= POS-EXP 3) `(*$ (*$ ,EXP-BASE ,EXP-BASE) ,EXP-BASE))
  101.     ((= POS-EXP 4)
  102.      `(INTERNAL-EXPT$ (INTERNAL-EXPT$ ,EXP-BASE 2) 2))
  103.     ((= pos-EXP 5)
  104.      `(*$ (INTERNAL-EXPT$ ,EXP-BASE 4) ,EXP-BASE))
  105.     ((= pos-exp 6)
  106.      `(internal-expt$ (internal-expt$ ,EXP-BASE 3) 2))
  107.     ((= pos-exp 7)
  108.      `(*$ ,EXP-BASE (internal-expt$ ,EXP-BASE 6)))
  109.     (T
  110.      `(*$ ,@(LISTN EXP-BASE POS-EXP)))))
  111.  
  112. ;;; There is a real neat and fancy way to do the above for arbitrary N
  113. ;;; repeated squaring in a recrusive fashion.  It is trivial to do
  114. ;;; and should be done at some point.
  115.  
  116. ;; (LISTN 'A 3) --> (A A A)
  117.  
  118. (DEFUN LISTN (X N)
  119.   (DO ((L NIL (CONS X L)))
  120.       ((MINUSP (SETQ N (f1- N))) L)))
  121.  
  122. #+PDP10
  123. (PROGN 'COMPILE
  124.  
  125. (DEFVAR *KNOWN-FUNCTIONS-INFO-STACK* NIL
  126.     "When MDEFUN expands it puts stuff here for MFUNCTION-CALL
  127.     to use.")
  128. (DEFVAR *UNKNOWN-FUNCTIONS-INFO-STACK* NIL
  129.     "When MFUNCTION-CALL expands without info from
  130.     *KNOWN-FUNCTIONS-INFO-STACK* it puts stuff here to be barfed
  131.     at the end of compilation.")
  132.  
  133. (DEFOPT MFUNCTION-CALL (F &REST ARGL
  134.               &AUX (INFO (GET-INFO F *KNOWN-FUNCTIONS-INFO-STACK*)))
  135.   (COND ((OR (MEMQ INFO '(LEXPR EXPR))
  136.          (GETL F '(*EXPR *LEXPR)))
  137.      `(,F ,@ (copy-rest-arg ARGL)))
  138.     ((GET F '*FEXPR)
  139.      (FORMAT MSGFILES
  140.          "~&(COMMENT *MACSYMA* unhandled FEXPR ~S may barf)~%"
  141.          F)
  142.      `(,F ,@ (copy-rest-arg ARGL)))
  143.     ((EQ INFO 'LUSER)
  144.      (COMMENT ???)
  145.      `(APPLY ',F ',(copy-rest-arg ARGL)))
  146.     (T
  147.      (PUSH-INFO F ARGL *UNKNOWN-FUNCTIONS-INFO-STACK*)
  148.      `(funcall (progn ',f) ,@  argl))))
  149.  
  150. ;;; A call to this macro is pushed onto the EOF-COMPILE-QUEUE
  151. (DECLARE (SPECIAL TTYNOTES))
  152. (DEFMACRO UNKNOWN-FUNCTIONS-COMMENT ()
  153.   (LET ((UNKNOWNS (RESOLVE-KNOWN-AND-UNKNOWN-FUNCTIONS))
  154.     (M1 "*MACSYMA* ")
  155.     (M2 "
  156.         -are user functions used but not defined in this file."))
  157.     (COND (UNKNOWNS
  158.        (SETQ UNKNOWNS
  159.          `(COMMENT ,M1 ,UNKNOWNS ,M2))
  160.        (COND (TTYNOTES
  161.           (TERPRI TYO)
  162.           (PRINT UNKNOWNS TYO)
  163.           (TERPRI TYO)))
  164.        UNKNOWNS))))
  165.  
  166. (DEFUN RESOLVE-KNOWN-AND-UNKNOWN-FUNCTIONS ()
  167.   (DO ((UN))
  168.       ((NULL *UNKNOWN-FUNCTIONS-INFO-STACK*)
  169.        UN)
  170.     (LET ((IND (TOP-IND *UNKNOWN-FUNCTIONS-INFO-STACK*)))
  171.       (POP-INFO IND *UNKNOWN-FUNCTIONS-INFO-STACK*)
  172.       (COND ((POP-INFO IND *KNOWN-FUNCTIONS-INFO-STACK*))
  173.         (T
  174.          (PUSH IND UN))))))
  175. ;; END OF #+PDP10
  176. )
  177.  
  178. #-(or PDP10 cl)
  179. (DEFOPT MFUNCTION-CALL (F &REST L)
  180.   (CONS F L))
  181.  
  182.  
  183. #+cl
  184. (DEFOPT MFUNCTION-CALL (F &REST L &aux l1)
  185.   #+lispm (setq l1 (copy-rest-arg l))
  186.   #-lispm (setq l1 l)
  187.   (cond((or (fboundp f)
  188.         (get f 'once-translated)
  189.         (get f 'translated))
  190.     (CONS F l1))
  191.        (t `(lispm-MFUNCTION-CALL-AUX ',f ', l1
  192.                      (list ,@ l1) NIL))))
  193.  
  194.  
  195. ;;; macros for compiled environments.
  196.  
  197. ;;; (FUNGEN&ENV-for-meval <eval vars list> <late eval vars list> .  <EXP>)
  198. ;;; will define a function globally with a unique name
  199. ;;; (defun <name> <list of variables> <exp>). And return
  200. ;;; `((<name>) ,@<eval>> . <late eval>). The resulting expression may
  201. ;;; then be passed to a function which will bind variables from
  202. ;;; the <late eval vars list> and possibly other variables free in
  203. ;;; <exp> and then call MEVAL on the expression.
  204. ;;; FUNGEN&ENV-FOR-MEVALSUMARG will also make sure that the <name>
  205. ;;; has an mevalsumarg property of T.
  206. ;;; the expression was translated using TR-LAMBDA.
  207.  
  208. (DEFVAR *INFILE-NAME-KEY* '||
  209.   "This is a key gotten from the infile name, in the interpreter
  210.   other completely hackish things with FSUBRS will go on.")
  211.  
  212. #+Maclisp
  213. (DEFUN GEN-NAME ( &OPTIONAL K &AUX (N '#,(*ARRAY NIL 'fixnum 1)))
  214.   (STORE (ARRAYCALL FIXNUM N 0) (f1+ (ARRAYCALL FIXNUM N 0)))
  215.   (AND K (STORE (ARRAYCALL FIXNUM N 0) K))
  216.   (IMPLODE (APPEND (EXPLODEN *INFILE-NAME-KEY*)
  217.            (EXPLODEN '|-tr-gen-|)
  218.            (EXPLODEN (ARRAYCALL FIXNUM N 0)))))
  219.  
  220. #+(OR CL NIL)
  221. (PROGN 'COMPILE
  222. (defvar a-random-counter-for-gen-name 0)
  223. (DEFUN GEN-NAME (&OPTIONAL IGNO) igno
  224.   (intern (format nil "~A ~A #~D"
  225.           (status site)
  226.           (get-universal-time)
  227.           (setq a-random-counter-for-gen-name
  228.             (f1+ a-random-counter-for-gen-name)))))
  229. )
  230.  
  231. (DEFUN ENSURE-A-CONSTANT-FOR-MEVAL (EXP)
  232.   (COND ((OR (NUMBERP EXP) (MEMQ EXP '(T NIL)))
  233.      EXP)
  234.     (T
  235.      `(LET ((VAL ,EXP))
  236.         (COND ((OR (NUMBERP VAL) (MEMQ VAL '(T NIL)))
  237.            VAL)
  238.           (T (LIST '(MQUOTE SIMP) VAL)))))))
  239.  
  240. (DEFMACRO PROC-EV (X)
  241.   `(MAPCAR #'ENSURE-A-CONSTANT-FOR-MEVAL ,X))
  242.  
  243. (defvar forms-to-compile-queue ())
  244.  
  245. (defun compile-forms-to-compile-queue-now ()  
  246.   (cond ( FORMS-TO-COMPILE-QUEUE
  247.      (sloop for v in FORMS-TO-COMPILE-QUEUE
  248.                    do (eval v) (compile (second v)))))
  249.   (SETQ FORMS-TO-COMPILE-QUEUE NIL))
  250.  
  251. (defmacro compile-forms-to-compile-queue ()
  252.   (IF FORMS-TO-COMPILE-QUEUE
  253.       (NCONC (LIST 'PROGN ''COMPILE)
  254.          (PROG1 FORMS-TO-COMPILE-QUEUE
  255.             (SETQ FORMS-TO-COMPILE-QUEUE NIL))
  256.          (LIST '(COMPILE-FORMS-TO-COMPILE-QUEUE)))))
  257.  
  258. (DEFUN EMIT-DEFUN (EXP)
  259.   (IF $TR_SEMICOMPILE (SETQ EXP `(PROGN ,EXP)))
  260.   #-CL
  261.   (SETQ FORMS-TO-COMPILE-QUEUE (NCONC FORMS-TO-COMPILE-QUEUE (LIST EXP)))
  262.   #+CL
  263.   (let #+lispm ((default-cons-area working-storage-area)) #-lispm nil
  264.       (SETQ FORMS-TO-COMPILE-QUEUE (NCONC FORMS-TO-COMPILE-QUEUE (LIST (COPY-TREE EXP))))))
  265.  
  266. (DEFOPT FUNGEN&ENV-FOR-MEVAL (EV EV-LATE EXP
  267.                    &AUX (NAME (GEN-NAME)))
  268.   (EMIT-DEFUN `(DEFUN ,NAME (,@EV ,@EV-LATE) ,EXP))
  269.   `(LIST* '(,NAME) ,@(PROC-EV EV)
  270.       ',EV-LATE))
  271.  
  272. (DEFOPT FUNGEN&ENV-FOR-MEVALSUMARG (EV EV-LATE TR-EXP MAC-EXP
  273.                      &AUX (NAME (GEN-NAME)))
  274.   (EMIT-DEFUN
  275.    `(DEFUN ,NAME (,@EV-LATE)
  276.       (LET ((,EV (GET ',NAME 'SUMARG-ENV)))
  277.     ,TR-EXP)))
  278.   
  279.   (EMIT-DEFUN
  280.    `(DEFUN-prop (,NAME MEVALSUMARG-MACRO) (*IGNORED*)
  281.       (MBINDING (',EV (GET ',NAME 'SUMARG-ENV))
  282.         (MEVALATOMS ',MAC-EXP))))
  283.   
  284.   `(PROGN (PUTPROP ',NAME (LIST ,@EV) 'SUMARG-ENV)
  285.       (LIST '(,NAME) ',@EV-LATE)))
  286.  
  287.  
  288. (defmacro pop-declare-statement (l)
  289.   `(and (not (atom (car ,l)))
  290.     (eq (caar ,l) 'declare)
  291.     (pop ,l)))
  292.  
  293.  
  294. ;;; the lambda forms.
  295. #+cl
  296. (progn 'compile
  297. (defmacro M-TLAMBDA (&REST L )
  298.   `(function (lambda ,(car l)
  299.            (declare (special ,@ (car l))) ,@ (copy-rest-arg (cdr  l)))))
  300. (defmacro m-tlambda& (argl &rest body)
  301.   `(function (lambda (,@(REVERSE (CDR (REVERSE ARGL)))
  302.         &REST ,@(LAST ARGL))
  303.      ,(pop-declare-statement body)
  304.      (SETQ ,(CAR (LAST ARGL))
  305.        (CONS '(MLIST) ,(CAR (LAST ARGL))))
  306.      ,@ BODY)))
  307.  
  308. (DEFmacro M-TLAMBDA&ENV ( argl &REST BODY
  309.                &AUX (NAME (GEN-NAME))
  310.                (reg-argl (first argl))(env-argl (second argl)))
  311.   `(function (lambda (,@ reg-argl) ,@ (copy-rest-arg body))))
  312. (defmacro M-TLAMBDA&ENV&  ( argl &REST BODY &aux (reg-argl (first argl)))
  313.   `(function (lambda ( ,@REG-ARGL) ,@ (copy-rest-arg BODY))))
  314.  (sloop for v in '(m-tlambda m-tlambda& m-tlambda&env m-tlambda&env&)
  315.       do
  316.       (remprop v 'opt)
  317.       #+lispm
  318.       (remprop v 'compiler:optimizers))
  319. )
  320. ;#+cl  ;;wrap function around the lambda forms.. 
  321. ;(progn 'compile
  322. ;(defmacro M-TLAMBDA (&REST L )
  323. ;  `(lambda ,@ (copy-rest-arg  l)))
  324. ;(defmacro m-tlambda& (argl &rest body)
  325. ;  `(lambda (,@(REVERSE (CDR (REVERSE ARGL)))
  326. ;        &REST ,@(LAST ARGL))
  327. ;     ,(pop-declare-statement body)
  328. ;     (SETQ ,(CAR (LAST ARGL))
  329. ;       (CONS '(MLIST) ,(CAR (LAST ARGL))))
  330. ;     ,@ BODY))
  331.  
  332. ;(DEFmacro M-TLAMBDA&ENV ( argl &REST BODY
  333. ;               &AUX (NAME (GEN-NAME))
  334. ;               (reg-argl (first argl))(env-argl (second argl)))
  335. ;  `(lambda (,@ reg-argl) ,@ (copy-rest-arg body)))
  336. ;(defmacro M-TLAMBDA&ENV&  ( argl &REST BODY &aux (reg-argl (first argl)))
  337. ;  `(lambda ( ,@REG-ARGL) ,@ (copy-rest-arg BODY)))
  338. ;(sloop for v in '(m-tlambda m-tlambda& m-tlambda&env m-tlambda&env&)
  339. ;      do
  340. ;      (remprop v 'opt)
  341. ;      (remprop v 'compiler:optimizers))
  342. ;)
  343.  
  344. ;#+lispm
  345. ;(DEFOPT M-TLAMBDA (&REST L &AUX (NAME (GEN-NAME)))
  346. ;    (EMIT-DEFUN
  347. ;    `(DEFPROP ,NAME APPLICATION-OPERATOR OPERATORS))
  348. ;
  349. ;  `(lambda ,@ (copy-rest-arg  l)))
  350. ;
  351. #-cl
  352. (DEFOPT M-TLAMBDA (&REST L &AUX (NAME (GEN-NAME)))
  353.   (EMIT-DEFUN `(DEFUN ,NAME ,@ (copy-rest-arg L)))
  354.   
  355.   ;; just in case this is getting passed in as
  356.   ;; SUBST(LAMBDA([U],...),"FOO",...)
  357.   ;; this little operator property will make sure the right thing
  358.   ;; happens!
  359.   
  360.   (EMIT-DEFUN
  361.     `(DEFPROP ,NAME APPLICATION-OPERATOR OPERATORS))
  362.   ;; must be 'NAME since #'NAME doesn't point to the operators
  363.   ;; property.
  364.   `',NAME)
  365.  
  366. ;(DEFOPT M-TLAMBDA& (ARGL &REST BODY &AUX body1 (NAME (GEN-NAME)))
  367. ;  (setq body1 (copy-rest-arg body))
  368. ;   `(lambda (,@(REVERSE (CDR (REVERSE ARGL)))
  369. ;          &REST ,@(LAST ARGL))
  370. ;      ,(pop-declare-statement body1)
  371. ;      (SETQ ,(CAR (LAST ARGL))
  372. ;        (CONS '(MLIST) ,(CAR (LAST ARGL))))
  373. ;      ,@BODY1))
  374.  
  375.  
  376. #-cl       
  377. (DEFOPT M-TLAMBDA& (ARGL &REST BODY &AUX (NAME (GEN-NAME)))
  378.   (EMIT-DEFUN
  379.    `(DEFUN ,NAME (,@(REVERSE (CDR (REVERSE ARGL)))
  380.           &REST ,@(LAST ARGL))
  381.       ,(pop-declare-statement body)
  382.       (SETQ ,(CAR (LAST ARGL))
  383.         (CONS '(MLIST) ,(CAR (LAST ARGL))))
  384.       ,@BODY))
  385.  
  386.   (EMIT-DEFUN `(DEFPROP ,NAME APPLICATION-OPERATOR OPERATORS))
  387.   `',NAME)
  388.  
  389. (DEFUN FOR-EVAL-THEN-QUOTE (VAR)
  390.   `(list 'QUOTE ,VAR))
  391.  
  392. (DEFUN FOR-EVAL-THEN-QUOTE-ARGL (ARGL)
  393.   (MAPCAR 'FOR-EVAL-THEN-QUOTE ARGL))
  394.  
  395. ;; Problem: You can pass a lambda expression around in macsyma
  396. ;; because macsyma "general-rep" has a CAR which is a list.
  397. ;; Solution: Just as well anyway.
  398.  
  399. ;;;eliminated that named function business for lispm
  400.  
  401. ;(DEFOPT M-TLAMBDA&ENV ( argl &REST BODY
  402. ;               &AUX  fun
  403. ;               (reg-argl (first argl))(env-argl (second argl)))
  404. ;  (setq fun `(lambda  (,@ENV-ARGL ,@REG-ARGL)
  405. ;         ,@ (copy-rest-arg BODY)))
  406. ;  `(MAKE-ALAMBDA ',REG-ARGL
  407. ;     (LIST* ',fun ,@(FOR-EVAL-THEN-QUOTE-ARGL ENV-ARGL) ',REG-ARGL)))
  408.  
  409. #+cl  ;;the lexical scoping  handles the environment in most cases
  410.       ;;and it is messy to queue things 
  411.  
  412.  
  413. #-cl
  414. (DEFOPT M-TLAMBDA&ENV ( argl &REST BODY
  415.                &AUX (NAME (GEN-NAME))
  416.                (reg-argl (first argl))(env-argl (second argl)))
  417.   (EMIT-DEFUN `(DEFUN ,NAME (,@ENV-ARGL ,@REG-ARGL)
  418.          ,@ (copy-rest-arg BODY)))
  419.   `(MAKE-ALAMBDA ',REG-ARGL
  420.      (LIST* ',NAME ,@(FOR-EVAL-THEN-QUOTE-ARGL ENV-ARGL) ',REG-ARGL)))
  421.  
  422. #-cl
  423. (DEFOPT M-TLAMBDA&ENV&  ( argl &REST BODY
  424.                &AUX (NAME (GEN-NAME))
  425.                (reg-argl (first argl))(env-argl (second argl)))
  426.   (EMIT-DEFUN `(DEFUN ,NAME (,@ENV-ARGL ,@REG-ARGL) ,@ (copy-rest-arg BODY)))
  427.   `(MAKE-ALAMBDA '*N*
  428.      (LIST* ',NAME ,@(FOR-EVAL-THEN-QUOTE-ARGL ENV-ARGL)
  429.         ',(DO ((N (LENGTH REG-ARGL))
  430.                (J 1 (f1+ J))
  431.                (L NIL))
  432.               ((= J N)
  433.                (PUSH `(CONS '(MLIST) (LISTIFY (f- ,(f1- N) *N*))) L)
  434.                (NREVERSE L))
  435.             (PUSH `(ARG ,J) L)))))
  436.  
  437. ;;; this is the important case for numerical hackery.
  438.  
  439. (DEFUN DECLARE-SNARF (BODY)
  440.   (COND ((AND (NOT (ATOM (CAR BODY)))
  441.           (EQ (CAAR BODY) 'DECLARE))
  442.      (LIST (CAR BODY)))
  443.     (T NIL)))
  444.  
  445.  
  446. ;;; I will use the special variable given by the NAME as a pointer to
  447. ;;; an environment.
  448.  
  449. (DEFOPT M-TLAMBDA-I (MODE ENV ARGL &REST BODY
  450.                 &AUX (NAME (GEN-NAME))
  451.                 (DECLAREP (DECLARE-SNARF BODY)))
  452.   (cond ((eq mode '$float)
  453.      (EMIT-DEFUN `(DECLARE (FLONUM (,NAME ,@(LISTN NIL (LENGTH ARGL))))))
  454.      (EMIT-DEFUN `(DEFPROP ,NAME T FLONUM-COMPILED))))
  455.   (EMIT-DEFUN
  456.    `(DEFUN ,NAME ,ARGL
  457.       ,@DECLAREP
  458.       (LET ((,ENV ,NAME))
  459.     ,@(COND (DECLAREP (CDR (copy-rest-arg BODY)))
  460.         (T (copy-rest-arg  BODY))))))
  461.   (EMIT-DEFUN #-NIL `(SETQ ,NAME ',(LISTN NIL (LENGTH ENV)))
  462.           #+NIL `(defparameter ,name (make-list ,(length env)))
  463.           )
  464.   `(PROGN (SET-VALS-INTO-LIST ,ENV ,NAME)
  465.       (QUOTE ,NAME)))
  466.  
  467. ;;; This is not optimal code.
  468. ;;; I.E. IT SUCKS ROCKS.
  469.  
  470. (DEFMACRO SET-VALS-INTO-LIST (ARGL VAR)
  471.   (DO ((J 0 (f1+ J))
  472.        (ARGL ARGL (CDR ARGL))
  473.        (L NIL
  474.       `((SETF (NTH ,J ,VAR) ,(CAR ARGL)) ,@L)))
  475.       ((NULL ARGL) `(PROGN ,@L))))
  476.  
  477.  
  478.  
  479.  
  480.  
  481.  
  482.  
  483.  
  484.